home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / f2c_src.zip / F2C / OUTPUT.C < prev    next >
C/C++ Source or Header  |  1991-06-10  |  38KB  |  1,432 lines
  1. /****************************************************************
  2. Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "names.h"
  26. #include "output.h"
  27.  
  28. #ifndef TRUE
  29. #define TRUE 1
  30. #endif
  31. #ifndef FALSE
  32. #define FALSE 0
  33. #endif
  34.  
  35. char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
  36.  
  37. /* Opcode table -- This array is indexed by the OP_____ macros defined in
  38.    defines.h; these macros are expected to be adjacent integers, so that
  39.    this table is as small as possible. */
  40.  
  41. table_entry opcode_table[] = {
  42.                 { 0, 0, NULL },
  43.     /* OPPLUS 1 */        { BINARY_OP, 12, "%l + %r" },
  44.     /* OPMINUS 2 */        { BINARY_OP, 12, "%l - %r" },
  45.     /* OPSTAR 3 */        { BINARY_OP, 13, "%l * %r" },
  46.     /* OPSLASH 4 */        { BINARY_OP, 13, "%l / %r" },
  47.     /* OPPOWER 5 */        { BINARY_OP,  0, "power (%l, %r)" },
  48.     /* OPNEG 6 */        { UNARY_OP,  14, "-%l" },
  49.     /* OPOR 7 */        { BINARY_OP,  4, "%l || %r" },
  50.     /* OPAND 8 */        { BINARY_OP,  5, "%l && %r" },
  51.     /* OPEQV 9 */        { BINARY_OP,  9, "%l == %r" },
  52.     /* OPNEQV 10 */        { BINARY_OP,  9, "%l != %r" },
  53.     /* OPNOT 11 */        { UNARY_OP,  14, "! %l" },
  54.     /* OPCONCAT 12 */    { BINARY_OP,  0, "concat (%l, %r)" },
  55.     /* OPLT 13 */        { BINARY_OP, 10, "%l < %r" },
  56.     /* OPEQ 14 */        { BINARY_OP,  9, "%l == %r" },
  57.     /* OPGT 15 */        { BINARY_OP, 10, "%l > %r" },
  58.     /* OPLE 16 */        { BINARY_OP, 10, "%l <= %r" },
  59.     /* OPNE 17 */        { BINARY_OP,  9, "%l != %r" },
  60.     /* OPGE 18 */        { BINARY_OP, 10, "%l >= %r" },
  61.     /* OPCALL 19 */        { BINARY_OP, 15, SPECIAL_FMT },
  62.     /* OPCCALL 20 */    { BINARY_OP, 15, SPECIAL_FMT },
  63.  
  64. /* Left hand side of an assignment cannot have outermost parens */
  65.  
  66.     /* OPASSIGN 21 */    { BINARY_OP,  2, "%l = %r" },
  67.     /* OPPLUSEQ 22 */    { BINARY_OP,  2, "%l += %r" },
  68.     /* OPSTAREQ 23 */    { BINARY_OP,  2, "%l *= %r" },
  69.     /* OPCONV 24 */        { BINARY_OP, 14, "%l" },
  70.     /* OPLSHIFT 25 */    { BINARY_OP, 11, "%l << %r" },
  71.     /* OPMOD 26 */        { BINARY_OP, 13, "%l %% %r" },
  72.     /* OPCOMMA 27 */    { BINARY_OP,  1, "%l, %r" },
  73.  
  74. /* Don't want to nest the colon operator in parens */
  75.  
  76.     /* OPQUEST 28 */    { BINARY_OP, 3, "%l ? %r" },
  77.     /* OPCOLON 29 */    { BINARY_OP, 3, "%l : %r" },
  78.     /* OPABS 30 */        { UNARY_OP,  0, "abs(%l)" },
  79.     /* OPMIN 31 */        { BINARY_OP,   0, SPECIAL_FMT },
  80.     /* OPMAX 32 */        { BINARY_OP,   0, SPECIAL_FMT },
  81.     /* OPADDR 33 */        { UNARY_OP, 14, "&%l" },
  82.  
  83.     /* OPCOMMA_ARG 34 */    { BINARY_OP, 15, SPECIAL_FMT },
  84.     /* OPBITOR 35 */    { BINARY_OP,  6, "%l | %r" },
  85.     /* OPBITAND 36 */    { BINARY_OP,  8, "%l & %r" },
  86.     /* OPBITXOR 37 */    { BINARY_OP,  7, "%l ^ %r" },
  87.     /* OPBITNOT 38 */    { UNARY_OP,  14, "~ %l" },
  88.     /* OPRSHIFT 39 */    { BINARY_OP, 11, "%l >> %r" },
  89.  
  90. /* This isn't quite right -- it doesn't handle arrays, for instance */
  91.  
  92.     /* OPWHATSIN 40 */    { UNARY_OP,  14, "*%l" },
  93.     /* OPMINUSEQ 41 */    { BINARY_OP,  2, "%l -= %r" },
  94.     /* OPSLASHEQ 42 */    { BINARY_OP,  2, "%l /= %r" },
  95.     /* OPMODEQ 43 */    { BINARY_OP,  2, "%l %%= %r" },
  96.     /* OPLSHIFTEQ 44 */    { BINARY_OP,  2, "%l <<= %r" },
  97.     /* OPRSHIFTEQ 45 */    { BINARY_OP,  2, "%l >>= %r" },
  98.     /* OPBITANDEQ 46 */    { BINARY_OP,  2, "%l &= %r" },
  99.     /* OPBITXOREQ 47 */    { BINARY_OP,  2, "%l ^= %r" },
  100.     /* OPBITOREQ 48 */    { BINARY_OP,  2, "%l |= %r" },
  101.     /* OPPREINC 49 */    { UNARY_OP,  14, "++%l" },
  102.     /* OPPREDEC 50 */    { UNARY_OP,  14, "--%l" },
  103.     /* OPDOT 51 */        { BINARY_OP, 15, "%l.%r" },
  104.     /* OPARROW 52 */    { BINARY_OP, 15, "%l -> %r"},
  105.     /* OPNEG1 53 */        { UNARY_OP,  14, "-%l" },
  106.     /* OPDMIN 54 */        { BINARY_OP, 0, "dmin(%l,%r)" },
  107.     /* OPDMAX 55 */        { BINARY_OP, 0, "dmax(%l,%r)" },
  108.     /* OPASSIGNI 56 */    { BINARY_OP,  2, "%l = &%r" },
  109.     /* OPIDENTITY 57 */    { UNARY_OP, 15, "%l" },
  110.     /* OPCHARCAST 58 */    { UNARY_OP, 14, "(char *)&%l" },
  111.     /* OPDABS 59 */        { UNARY_OP, 0, "dabs(%l)" },
  112.     /* OPMIN2 60 */        { BINARY_OP,   0, "min(%l,%r)" },
  113.     /* OPMAX2 61 */        { BINARY_OP,   0, "max(%l,%r)" },
  114.  
  115. /* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
  116.  
  117.     /* OPNEG KLUDGE */    { UNARY_OP,  14, "-(doublereal)%l" }
  118. }; /* opcode_table */
  119.  
  120. #define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
  121.  
  122. static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
  123.  
  124.  
  125. static void output_prim ();
  126. static void output_unary (), output_binary (), output_arg_list ();
  127. static void output_list (), output_literal ();
  128.  
  129.  
  130. void expr_out (fp, e)
  131. FILE *fp;
  132. expptr e;
  133. {
  134.     if (e == (expptr) NULL)
  135.     return;
  136.  
  137.     switch (e -> tag) {
  138.     case TNAME:    out_name (fp, (struct Nameblock *) e);
  139.             return;
  140.  
  141.     case TCONST:    out_const(fp, &e->constblock);
  142.             goto end_out;
  143.     case TEXPR:
  144.                 break;
  145.  
  146.     case TADDR:    out_addr (fp, &(e -> addrblock));
  147.             goto end_out;
  148.  
  149.     case TPRIM:    warn ("expr_out: got TPRIM");
  150.             output_prim (fp, &(e -> primblock));
  151.             return;
  152.  
  153.     case TLIST:    output_list (fp, &(e -> listblock));
  154.  end_out:        frexpr(e);
  155.             return;
  156.  
  157.     case TIMPLDO:    err ("expr_out: got TIMPLDO");
  158.             return;
  159.  
  160.     case TERROR:
  161.     default:
  162.             erri ("expr_out: bad tag '%d'", e -> tag);
  163.     } /* switch */
  164.  
  165. /* Now we know that the tag is TEXPR */
  166.  
  167. /* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
  168.  
  169.     if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
  170.     e -> exprblock.rightp -> tag == TEXPR) {
  171.     int opcode;
  172.  
  173.     opcode = e -> exprblock.rightp -> exprblock.opcode;
  174.  
  175.     if (opeqable[opcode]) {
  176.         expptr leftp, rightp;
  177.  
  178.         if ((leftp = e -> exprblock.leftp) &&
  179.         (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
  180.  
  181.         if (same_ident (leftp, rightp)) {
  182.             expptr temp = e -> exprblock.rightp;
  183.  
  184.             e -> exprblock.opcode = op_assign(opcode);
  185.  
  186.             e -> exprblock.rightp = temp -> exprblock.rightp;
  187.             temp->exprblock.rightp = 0;
  188.             frexpr(temp);
  189.         } /* if same_ident (leftp, rightp) */
  190.         } /* if leftp && rightp */
  191.     } /* if opcode == OPPLUS || */
  192.     } /* if e -> exprblock.opcode == OPASSIGN */
  193.  
  194.  
  195. /* Optimize on increment or decrement by 1 */
  196.  
  197.     {
  198.     int opcode = e -> exprblock.opcode;
  199.     expptr leftp = e -> exprblock.leftp;
  200.     expptr rightp = e -> exprblock.rightp;
  201.  
  202.     if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
  203.         ISINT (leftp -> headblock.vtype)) &&
  204.         (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
  205.         ISINT (rightp -> headblock.vtype) &&
  206.         ISICON (e -> exprblock.rightp) &&
  207.         (ISONE (e -> exprblock.rightp) ||
  208.         e -> exprblock.rightp -> constblock.Const.ci == -1)) {
  209.  
  210. /* Allow for the '-1' constant value */
  211.  
  212.         if (!ISONE (e -> exprblock.rightp))
  213.         opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
  214.  
  215. /* replace the existing opcode */
  216.  
  217.         if (opcode == OPPLUSEQ)
  218.         e -> exprblock.opcode = OPPREINC;
  219.         else
  220.         e -> exprblock.opcode = OPPREDEC;
  221.  
  222. /* Free up storage used by the right hand side */
  223.  
  224.         frexpr (e -> exprblock.rightp);
  225.         e->exprblock.rightp = 0;
  226.     } /* if opcode == OPPLUS */
  227.     } /* block */
  228.  
  229.  
  230.     if (is_unary_op (e -> exprblock.opcode))
  231.     output_unary (fp, &(e -> exprblock));
  232.     else if (is_binary_op (e -> exprblock.opcode))
  233.     output_binary (fp, &(e -> exprblock));
  234.     else
  235.     erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
  236.  
  237.     free((char *)e);
  238.  
  239. } /* expr_o